(in-package #:cl-fast-ecs/tests)

(define-test components
  :parent cl-fast-ecs)

(defparameter *deleted-name* nil)
(defparameter *deleted-entity* nil)

(defcomponent (coordinate
               :finalize (lambda (entity &key x y name)
                           (declare (ignore x y))
                           (setf *deleted-name* name
                                 *deleted-entity* entity))
               :composite-index (composite (x name)))
  "test component"
  (x 0.0 :type single-float :documentation "X")
  (y 0.0 :type single-float :documentation "Y")
  (name :|| :type keyword :index name-entities))

(define-test component-registry
  :parent components
  (is eq :coordinate (first ecs::*component-registry*))
  (is = 1 ecs::*component-registry-length*))

(define-test make-component-macro
  :parent components
  (make-storage)
  (let ((entity (make-entity))
        (x 42.0)
        (y 42.9))
    (make-coordinate entity :x x :y y)
    (is = x (coordinate-x entity))
    (is = y (coordinate-y entity))))

(define-test make-component
  :parent components
  (make-storage)
  (let ((entity (make-entity))
        (x 42.0)
        (y 42.9))
    (make-component ecs::+coordinate-component-index+ entity :x x :y y)
    (is = x (coordinate-x entity))
    (is = y (coordinate-y entity))))

(define-test delete-component
  :parent components
  (make-storage)
  (let ((entity (make-entity)))
    (make-coordinate entity :x 42.0 :y 42.9)
    (delete-coordinate entity)
    (false (has-coordinate-p entity))
    #-ecs-release (is = 0.0 (coordinate-x entity))
    #-ecs-release (is = 0.0 (coordinate-y entity))))

(define-test with-macro
  :parent components
  (make-storage)
  (let ((entity (make-entity))
        (x0 42.0)
        (y0 42.9))
    (make-coordinate entity :x x0 :y y0)
    (with-coordinate () entity
      (is = x0 x)
      (is = y0 y))))

(define-test with-macro-prefixed-slots
  :parent components
  (make-storage)
  (let ((entity (make-entity))
        (x0 42.0)
        (y0 42.9))
    (make-coordinate entity :x x0 :y y0)
    (with-coordinate t entity
      (is = x0 coordinate-x)
      (is = y0 coordinate-y))))

(define-test test-component-write-access
  :parent components
  (make-storage)
  (let ((entity (make-entity))
        (x 42.0)
        (y 42.9))
    (make-coordinate entity)
    (setf (coordinate-x entity) x)
    (setf (coordinate-y entity) y)
    (is = x (coordinate-x entity))
    (is = y (coordinate-y entity))))

(define-test with-slots-ro-macro
  :parent components
  (make-storage)
  (let ((entity (make-entity))
        (component-storages (ecs::storage-component-storages *storage*))
        (x0 42.0)
        (y0 42.9))
    (make-coordinate entity :x x0 :y y0)
    (%with-coordinate-slots () t component-storages entity
      (is = x0 coordinate-x)
      (is = y0 coordinate-y))
    (fail
     (%with-coordinate-slots () t component-storages entity
       (setf coordinate-x 0.1)))))

(define-test new-component-definition
  :parent components
  :depends-on (component-registry)
  #+ecs-release
  (eval
   '(define-component (velocity
                       :composite-index (velocity (x y) :unique t))
     (x 0.0 :type single-float)
     (y 0.0 :type single-float)))
  (make-storage)
  (let ((entity (make-entity))
        (x 42.0)
        (y 42.9))
    ;; HACK : silence the warning, not likely to happen in real usage scenarios
    (declare (notinline velocity-x velocity-y))
    #-ecs-release
    (eval
     '(define-component (velocity
                         :composite-index (velocity (x y) :unique t))
       (x 0.0 :type single-float)
       (y 0.0 :type single-float)))
    (make-velocity entity :x x :y y)
    (is eq :velocity (first ecs::*component-registry*))
    (is eq :coordinate (third ecs::*component-registry*))
    (is = 2 ecs::*component-registry-length*)
    (is = x (velocity-x entity))
    (is = y (velocity-y entity))))

#+sbcl
(define-test defcomponent-with-shadowed-symbol
  :parent components
  :depends-on (component-registry new-component-definition)
  (with-fixtures '(ecs::*component-registry* ecs::*component-registry-length*)
    (let ((compilation-output
            (let ((*error-output* (make-string-output-stream))
                  (*standard-output* (make-string-output-stream)))
              (finish
               (compile-file #P"tests/test-component-shadow.lisp" :verbose nil))
              (get-output-stream-string *error-output*))))
      (false (search "undefined function" compilation-output)))))

(define-test
    "component ctor fails with non-unique data for unique composite index"
  :parent components
  :depends-on (component-registry new-component-definition)
  (make-storage)
  (let ((entity (make-entity))
        (entity2 (make-entity))
        (x 42.0)
        (y 42.9))
    (make-velocity entity :x x :y y)
    (fail (make-velocity entity2 :x x :y y))))

(define-test "error getting nonexistent data from unique composite index"
  :parent components
  :depends-on (component-registry new-component-definition)
  (make-storage)
  (let ((entity (make-entity))
        (x 42.0)
        (y 42.9))
    (make-velocity entity :x x :y y)
    (fail (velocity :x 0.0 :y 0.0))))

(define-test "no error getting nonexistent data from unique composite index"
  :parent components
  :depends-on (component-registry new-component-definition)
  (make-storage)
  (let ((entity (make-entity))
        (x 42.0)
        (y 42.9))
    (make-velocity entity :x x :y y)
    (true (minusp (velocity :x 0.0 :y 0.0 :missing-error-p nil)))))

(define-test dtor-composite-index-unique
  :parent components
  :depends-on (component-registry new-component-definition)
  (make-storage)
  (let ((entity (make-entity))
        (x 42.0)
        (y 42.9))
    (make-velocity entity :x x :y y)
    (delete-velocity entity)
    (fail (velocity :x x :y y))))

(define-test component-setter-uniqueness-in-composite-index
  :parent components
  :depends-on (component-registry new-component-definition)
  (make-storage)
  (let* ((x 42.0)
         (y 42.9)
         (entity (make-object `((:velocity)))))
    (make-object `((:velocity :x ,x :y ,y)))
    (setf (velocity-x entity) x)
    (fail (setf (velocity-y entity) y))))

(define-test
    "with- macro fails setting non-unique data in unique composite index"
  :parent components
  :depends-on (component-registry new-component-definition)
  (make-storage)
  (let* ((x* 42.0)
         (y* 42.9)
         (entity2 (make-object `((:velocity)))))
    (declare (special entity2 x* y*))
    (make-object `((:velocity :x ,x* :y ,y*)))
    (fail
     (eval
      '(with-velocity () entity2
        (setf x x*)
        (setf y y*))))))

(define-test empty-component
  :parent components
  :depends-on (component-registry new-component-definition
                                  component-name-clash-with-cl)
  (with-fixtures '(ecs::*system-registry*)
    (eval
     '(defcomponent tag (name :|| :type keyword :index tag-entity :unique t)))
    (make-storage)
    (let ((entity (make-entity))
          (visited-entities nil))
      (declare (special entity visited-entities))
      (false (has-tag-p entity))
      (make-tag entity)
      (true (has-tag-p entity))
      (delete-tag entity)
      (false (has-tag-p entity))
      (finish (eval '(with-tag () entity)))
      (eval
       '(defsystem test-tag
         (:components-ro (tag))
         (push entity visited-entities)))
      (run-systems)
      (is equal nil visited-entities)
      (make-tag entity)
      (run-systems)
      (is equal visited-entities (list entity)))))

(define-test "component-storage-grown-hook called"
  :parent components
  (make-storage :initial-allocated 2)
  (let* ((hook-run-p nil)
         (hook (lambda (i n) (declare (ignore i n)) (setf hook-run-p t))))
    (false hook-run-p "hook wasn't run initially")
    (hook-up *component-storage-grown-hook* hook)
    (make-object `((:coordinate)))
    (make-object `((:coordinate)))
    (make-object `((:coordinate)))
    (true hook-run-p "hook run after reallocation")))

(define-test defcomponent-docstring
  :parent components
  (make-storage)
  (is string= "test component"
      (documentation (type-of
                      (aref (ecs::storage-component-storages *storage*) 0))
                     #-ecs-release 'type
                     #+ecs-release 'structure)))

#-(and clisp ecs-release)
;; CLISP appears to elide docstrings for compiled inline functions
(define-test defcomponent-slot-docstring
  :parent components
  (is string= "X" (documentation #'coordinate-x 'function))
  (is string= "Y" (documentation #'coordinate-y 'function)))

(define-test defcomponent+defsystem
  :parent components
  :depends-on (component-registry new-component-definition)
  (with-fixtures '(ecs::*system-registry*
                   ecs::*component-registry* ecs::*component-registry-length*)
    (let ((compilation-output
            (let ((*error-output* (make-string-output-stream))
                  (*standard-output* (make-string-output-stream)))
              (finish
               (compile-file #P"tests/test-component+system.lisp" :verbose nil))
              (get-output-stream-string #+ecl *standard-output*
                                        #-ecl *error-output*))))
      (false
       (search "Following components are undefined" compilation-output))))
  #+clisp (setf ecs::*component-registry* (cddr ecs::*component-registry*)))

(define-test defcomponent-default
  :parent components
  :depends-on (component-registry new-component-definition)
  (setf ecs:*storage* nil)
  (with-fixtures '(ecs::*system-registry*
                   ecs::*component-registry* ecs::*component-registry-length*)
    (let ((compilation-output
            (let ((*error-output* (make-string-output-stream))
                  (*standard-output* (make-string-output-stream)))
              (finish
               (compile-file #P"tests/test-component-default.lisp"
                             :verbose nil))
              (get-output-stream-string #+ecl *standard-output*
                                        #-ecl *error-output*))))
      (declare (ignore compilation-output))))
  #+clisp (setf ecs::*component-registry* (cddr ecs::*component-registry*)))

#+(or sbcl)
(define-test ctor-no-hairy-vectors
  :parent components
  (let ((disassembly (let ((*standard-output* (make-string-output-stream)))
                       (disassemble #'make-coordinate)
                       (get-output-stream-string *standard-output*))))
    (false (search #+sbcl "HAIRY" disassembly))))

#+(or sbcl)
(define-test dtor-no-hairy-vectors
  :parent components
  (let ((disassembly (let ((*standard-output* (make-string-output-stream)))
                       (disassemble #'delete-coordinate)
                       (get-output-stream-string *standard-output*))))
    (false (search #+sbcl "HAIRY" disassembly))))

#+(or sbcl)
(define-test accessor-no-hairy-vectors
  :parent components
  (let ((disassembly (let ((*standard-output* (make-string-output-stream)))
                       (disassemble #'coordinate-x)
                       (get-output-stream-string *standard-output*))))
    (false (search #+sbcl "HAIRY" disassembly))))

#+(or sbcl)
(define-test with-macro-no-sxhash
  :parent components
  :depends-on (empty-component)
  (make-storage)
  (let ((disassembly (let ((*standard-output* (make-string-output-stream)))
                       (disassemble #'assign-tag)
                       (get-output-stream-string *standard-output*))))
    (false (search #+sbcl "SXHASH" disassembly))))

#+sbcl
(defun method-fn (method qualifiers specializers)
  (slot-value
   (sb-mop:method-function
    (find-method method qualifiers specializers))
   'sb-pcl::fast-function))

#+sbcl
(define-test print-entity-no-hairy-vectors
  :parent components
  (let ((disassembly (let ((*standard-output* (make-string-output-stream)))
                       (disassemble
                        (method-fn #'print-component nil
                                   `((eql ,ecs::+coordinate-component-index+) t)))
                       (get-output-stream-string *standard-output*))))
    (false (search "HAIRY" disassembly))))

(defun count-in-index (index item)
  (loop :for bucket :across index
        :unless (null bucket)
        :sum (count item bucket :start 1 :test #'=)))

(define-test defcomponent-with-index
  :parent components
  (make-storage)
  (dotimes (_ 4)
    (make-object `((:coordinate :name :test))))

  (let ((index (%coordinate-soa-name-index
                (aref
                 (ecs::storage-component-storages *storage*)
                 ecs::+coordinate-component-index+))))
    (is = 1 (count-in-index index 0))
    (is = 1 (count-in-index index 1))
    (is = 1 (count-in-index index 2))
    (is = 1 (count-in-index index 3))))

(define-test defcomponent-with-unique-index
  :parent components
  :depends-on (empty-component)
  (make-storage)
  (loop :for name :in '(:test1 :test2 :test3 :test4)
        :do (make-object `((:tag :name ,name))))
  
  (let ((index (%tag-soa-name-index
                (aref (ecs::storage-component-storages *storage*)
                      ecs::+tag-component-index+))))
    (is = 1 (count-in-index index 0))
    (is = 1 (count-in-index index 1))
    (is = 1 (count-in-index index 2))
    (is = 1 (count-in-index index 3))))

(define-test index-removal
  :parent components
  (make-storage)
  (dotimes (_ 4)
    (make-object `((:coordinate :name :test))))
  (delete-coordinate 3)
  (let ((index (%coordinate-soa-name-index
                (aref
                 (ecs::storage-component-storages *storage*)
                 ecs::+coordinate-component-index+))))
    (is = 1 (count-in-index index 0))
    (is = 1 (count-in-index index 1))
    (is = 1 (count-in-index index 2))
    (is = 0 (count-in-index index 3))))

(define-test "unique index removal"
  :parent components
  :depends-on (empty-component)
  (make-storage)
  (loop :for name :in '(:test1 :test2 :test3 :test4)
        :do (make-object `((:tag :name ,name))))
  (delete-tag 2)
  (fail (tag-entity :test3)))

(define-test "lone unique keyword"
  :parent components
  (fail (eval '(defcomponent id (name "" :type string :unique t)))))

(define-test index-accessor
  :parent components
  (make-storage)
  (loop :for name :in '(:test1 :test2 :test3 :test1 :test2 :test4)
        :do (make-object `((:coordinate :name ,name))))
  (is alexandria:set-equal '(0 3) (name-entities :test1))
  (is alexandria:set-equal '(1 4) (name-entities :test2))
  (is alexandria:set-equal '(2) (name-entities :test3))
  (is alexandria:set-equal '(5) (name-entities :test4)))

(define-test unique-index-uniqueness
  :parent components
  :depends-on (empty-component)
  (make-storage)
  (make-object `((:tag :name :test)))
  (fail (make-object `((:tag :name :test)))))

(define-test unique-index-accessor
  :parent components
  :depends-on (empty-component)
  (make-storage)
  (loop :for name :in '(:test1 :test2 :test3 :test4)
        :do (make-object `((:tag :name ,name))))
  (is = 0 (tag-entity :test1))
  (is = 1 (tag-entity :test2))
  (is = 2 (tag-entity :test3))
  (is = 3 (tag-entity :test4)))

(define-test index-updated
  :parent components
  (make-storage)
  (loop :for name :in '(:test1 :test2 :test2 :test3)
        :do (make-object `((:coordinate :name ,name))))
  (setf (coordinate-name 0) :test2)
  (setf (coordinate-name 3) :test4)

  (is alexandria:set-equal '() (name-entities :test1))
  (is alexandria:set-equal '(0 1 2) (name-entities :test2))
  (is alexandria:set-equal '() (name-entities :test3))
  (is alexandria:set-equal '(3) (name-entities :test4)))

(define-test unique-index-updated
  :parent components
  :depends-on (empty-component)
  (make-storage)
  (loop :for name :in '(:test1 :test2 :test3 :test4)
        :do (make-object `((:tag :name ,name))))
  (setf (tag-name 0) :test5)
  (setf (tag-name 1) :test1)
  (setf (tag-name 2) :test)
  (setf (tag-name 3) :test3)
  (setf (tag-name 2) :test4)

  (let ((tag-index (%tag-soa-name-index
                    (aref (ecs::storage-component-storages *storage*)
                          ecs::+tag-component-index+))))
    (is = 1 (count-in-index tag-index 0))
    (is = 1 (count-in-index tag-index 1))
    (is = 1 (count-in-index tag-index 2))
    (is = 1 (count-in-index tag-index 3)))

  (is = 1 (tag-entity :test1))
  (fail (tag-entity :test2))
  (is = 3 (tag-entity :test3))
  (is = 2 (tag-entity :test4)))

(define-test unique-index-with-macro
  :parent components
  :depends-on (empty-component)
  (make-storage)

  (loop :for name :in '(:test1 :test2 :test3 :test4)
        :do (make-object `((:tag :name ,name))))

  (eval '(with-tag () 0
          (setf name :test5)))
  (eval '(with-tag () 1
          (setf name :test1)))
  (eval '(with-tag () 2
          (setf name :test)))
  (eval '(with-tag () 3
          (setf name :test3)))
  (eval '(with-tag () 2
          (setf name :test4)))

  (is = 1 (tag-entity :test1))
  (fail (tag-entity :test2))
  (is = 3 (tag-entity :test3))
  (is = 2 (tag-entity :test4)))

(define-test index-with-macro
  :parent components
  (make-storage)
  (let (i)
    (loop :for name :in '(:test1 :test2 :test3 :test1 :test2 :test4)
          :do (make-object `((:coordinate :name ,name))))
    (setf i 0)
    (with-name-entities :test1 entity
      (if (zerop i)
          (is = 0 entity)
          (is = 3 entity))
      (incf i))
    (setf i 0)
    (with-name-entities :test2 entity
      (if (zerop i)
          (is = 1 entity)
          (is = 4 entity))
      (incf i))
    (with-name-entities :test3 entity
      (is = 2 entity))
    (with-name-entities :test4 entity
      (is = 5 entity))))

(define-test index-order
  :parent components
  (make-storage)

  (dotimes (e 6)
    (make-entity))

  (make-coordinate 3 :name :test)
  (make-coordinate 1 :name :test)
  (make-coordinate 4 :name :test)
  (make-coordinate 2 :name :test)
  (make-coordinate 5 :name :test)

  (let ((coordinate-index (%coordinate-soa-name-index
                         (aref
                          (ecs::storage-component-storages *storage*)
                          ecs::+coordinate-component-index+))))
    (is equalp #(5 1 2 3 4 5)
        (find-if-not #'null coordinate-index))))

(define-test accessing-nonexistent-value-from-index
  :parent components
  (make-storage)
  (loop :for name :in '(:test1 :test2 :test3 :test1)
        :do (make-object `((:coordinate :name ,name))))
  (is equal nil (name-entities :test4)))

(define-test accessing-nonexistent-value-from-index-with-macro
  :parent components
  (make-storage)
  (loop :for name :in '(:test1 :test2 :test3 :test1)
        :do (make-object `((:coordinate :name ,name))))
  (finish (with-name-entities :test4 entity
            (print entity))))

(define-test accessing-nonexistent-value-from-unique-index
  :parent components
  :depends-on (empty-component)
  (make-storage)
  (loop :for name :in '(:test1 :test2 :test3)
        :do (make-object `((:tag :name ,name))))
  (handler-case (tag-entity :test4)
    (error (error)
      (isnt typep 'type-error error))))

(define-test accessing-nonexistent-value-from-unique-index-with-no-condition
  :parent components
  :depends-on (empty-component)
  (make-storage)
  (loop :for name :in '(:test1 :test2 :test3)
        :do (make-object `((:tag :name ,name))))
  (true (minusp (tag-entity :test4 :missing-error-p nil))))

(define-test index-count
  :parent components
  (make-storage)
  (loop :for name :in '(:test1 :test2 :test1 :test1 :test1)
        :do (make-object `((:coordinate :name ,name))))
  (is equal '(0 2 3 4) (name-entities :test1 :count 5))
  (is equal '(0 2) (name-entities :test1 :count 2)))

(define-test index-count-with-collisions
  :parent components
  (make-storage)
  (loop :for name :in '(:test1 :test2 :test3 :test4 :test5 :test1)
        :do (make-object `((:coordinate :name ,name))))
  (is equal '(0 5) (name-entities :test1 :count 2))
  (is equal '(0) (name-entities :test1 :count 1)))

(define-test index-start
  :parent components
  (make-storage)
  (loop :for name :in '(:test1 :test2 :test1 :test1 :test1)
        :do (make-object `((:coordinate :name ,name))))
  (is equal '(0 2 3 4) (name-entities :test1 :start 0))
  (is equal '(2 3 4) (name-entities :test1 :start 1))
  (is equal '() (name-entities :test1 :start 4)))

(define-test index-start-with-collisions
  :parent components
  (make-storage)
  (loop :for name :in '(:test1 :test2 :test3 :test4 :test5 :test1)
        :do (make-object `((:coordinate :name ,name))))
  (is equal '(5) (name-entities :test1 :start 1)))

(define-test index-start-with-count
  :parent components
  (make-storage)
  (loop :for name :in '(:test1 :test2 :test1 :test1 :test1)
        :do (make-object `((:coordinate :name ,name))))
  (is equal '(2 3) (name-entities :test1 :start 1 :count 2)))

(define-test printer
  :parent components
  (make-storage)
  (let* ((x 42.0)
         (y 42.9)
         (name :test)
         (entity (make-object `((:coordinate :x ,x :y ,y :name ,name)))))
    (is equal
        `(:coordinate :x ,x :y ,y :name ,name)
        (print-component ecs::+coordinate-component-index+ entity
                         (make-broadcast-stream)))))

(define-test defcomponent-slot-dependencies
  :parent components
  :depends-on (component-registry)
  (eval
   '(defcomponent (velocity
                   :composite-index (velocity (x y) :unique t))
                  (x 0.0 :type single-float)
                  (y 0.0 :type single-float)
                  (sum (+ x y) :type single-float)))
  (make-storage :initial-allocated 2)
  (let ((entity (make-entity))
        (x 42.0)
        (y 42.9))
    ;; HACK : silence the warning, not likely to happen in real usage scenarios
    (declare (notinline velocity-x velocity-y))
    (make-velocity entity)
    (is = 0.0 (velocity-sum entity))
    (let ((object (make-object `((:velocity :x ,x :y ,y)))))
      (is = (+ x y) (velocity-sum object)))
    (true (null (delete-velocity entity)))))

(define-test defcomponent-finalizer
  :parent components
  (make-storage)
  (let* ((name :test)
         (entity (make-object `((:coordinate :name ,name)))))
    (setf *deleted-name* nil)
    (delete-coordinate entity)
    (is eq name *deleted-name*)))

(define-test entity-finalizer
  :parent components
  (make-storage)
  (let* ((name :test)
         (entity (make-object `((:coordinate :name ,name)))))
    (setf *deleted-name* nil)
    (delete-entity entity)
    (is eq name *deleted-name*)))

(define-test finalizer-gets-entity
  :parent components
  (make-storage)
  (let* ((entity (make-object `((:coordinate)))))
    (setf *deleted-entity* nil)
    (delete-entity entity)
    (is eq entity *deleted-entity*)))

(define-test assign-component
  :parent components
  (make-storage)
  (let* ((x 42.0)
         (y 42.1)
         (x1 0.1)
         (y1 0.2)
         (name :test)
         (name1 :test1)
         (entity (make-object `((:coordinate :x ,x :y ,y :name ,name))))
         (entity1 (make-entity)))
    (is eq nil
        (assign-coordinate entity :x x1 :y y1 :name name1))
    (with-coordinate () entity
      (is = x1 x)
      (is = y1 y))
    (true (has-coordinate-p entity))
    (is alexandria:set-equal (list entity) (name-entities name1))

    (is eq nil
     (assign-coordinate entity1 :x x1 :y y1 :name name))
    (with-coordinate () entity
      (is = x1 x)
      (is = y1 y))
    (true (has-coordinate-p entity))
    (is alexandria:set-equal (list entity1) (name-entities name))))

(define-test assign-component-generic
  :parent components
  (make-storage)
  (let* ((x 42.0)
         (y 42.1)
         (x1 0.1)
         (y1 0.2)
         (name :test)
         (name1 :test1)
         (entity (make-object `((:coordinate :x ,x :y ,y :name ,name))))
         (entity1 (make-entity)))
    (is eq nil
        (assign-component ecs::+coordinate-component-index+
                          entity :x x1 :y y1 :name name1))
    (with-coordinate () entity
      (is = x1 x)
      (is = y1 y))
    (true (has-coordinate-p entity))
    (is alexandria:set-equal (list entity) (name-entities name1))

    (is eq nil
        (assign-component ecs::+coordinate-component-index+
                          entity1 :x x1 :y y1 :name name))
    (with-coordinate () entity
      (is = x1 x)
      (is = y1 y))
    (true (has-coordinate-p entity))
    (is alexandria:set-equal (list entity1) (name-entities name))))

(define-test assign-component-keeps-unassigned-slot-values
  :parent components
  (make-storage)
  (let* ((x1 42.0)
         (y1 42.1)
         (x2 0.1)
         (name1 :test1)
         (entity (make-object `((:coordinate :x ,x1 :y ,y1 :name ,name1)))))
    (assign-coordinate entity :x x2)
    (with-coordinate () entity
      (is = y1 y)
      (is eq name1 name))))

(define-test replace-component
  :parent components
  (make-storage)
  (let* ((x1 42.0)
         (y1 42.1)
         (name1 :test1)
         (entity0 (make-object `((:coordinate :x ,x1 :y ,y1 :name ,name1))))
         (entity (make-object `((:coordinate))))
         (entity1 (make-entity)))
    (is eq entity
        (replace-coordinate entity entity0))
    (with-coordinate () entity
      (is = x1 x)
      (is = y1 y)
      (is eq name1 name))
    (true (has-coordinate-p entity))
    (is alexandria:set-equal (list entity0 entity)
        (name-entities name1))

    (is eq entity1
        (replace-coordinate entity1 entity0))
    (with-coordinate () entity1
      (is = x1 x)
      (is = y1 y)
      (is eq name1 name))
    (true (has-coordinate-p entity1))
    (is alexandria:set-equal (list entity0 entity1 entity)
        (name-entities name1))))

(define-test no-replace-component-with-unique-index
  :parent components
  :depends-on (empty-component)
  (false (fboundp 'replace-tag)))

(define-test replace-component
  :parent components
  :depends-on (empty-component)
  (make-storage)
  (let* ((x1 42.0)
         (y1 42.1)
         (name1 :test1)
         (entity0 (make-object `((:coordinate :x ,x1 :y ,y1 :name ,name1))))
         (entity (make-object `((:coordinate))))
         (entity1 (make-entity)))
    (is eq entity
        (replace-component ecs::+coordinate-component-index+ entity entity0))
    (with-coordinate () entity
      (is = x1 x)
      (is = y1 y)
      (is eq name1 name))
    (true (has-coordinate-p entity))
    (is alexandria:set-equal (list entity0 entity)
        (name-entities name1))

    (is eq entity1
        (replace-component ecs::+coordinate-component-index+ entity1 entity0))
    (with-coordinate () entity1
      (is = x1 x)
      (is = y1 y)
      (is eq name1 name))
    (true (has-coordinate-p entity1))
    (is alexandria:set-equal (list entity0 entity1 entity)
        (name-entities name1))

    (fail (replace-component ecs::+tag-component-index+ entity entity0))))

(define-test composite-index-accessor-arguments
  :parent components
  (make-storage)
  (let ((entity (make-entity))
        (entity2 (make-entity))
        (x 42.0)
        (y 42.9))
    (declare (ignore entity2))
    (make-coordinate entity :x x :y y)
    (fail (composite))))

(define-test incorrect-composite-index
  :parent components
  (fail
   (eval
    '(defcomponent (velocity
                    :composite-index (velocity (x)))
      (x 0.0 :type single-float)
      (y 0.0 :type single-float))))
  (fail
   (eval
    '(defcomponent (velocity
                    :composite-index (velocity (x rawr q)))
      (x 0.0 :type single-float)
      (y 0.0 :type single-float))))
  (fail
   (eval
    '(defcomponent (velocity
                    :composite-index (velocity (x y missing-error-p) :unique t))
      (x 0.0 :type single-float)
      (y 0.0 :type single-float)
      (missing-error-p nil :type t)))))

(define-test "component ctor updates composite index"
  :parent components
  (make-storage)
  (let ((entity (make-entity))
        (x 42.0)
        (y 42.9)
        (name :test))
    (make-coordinate entity :x x :y y :name name)
    (is equal (list entity) (composite :x x :name name))))

(define-test "component ctors update composite index"
  :parent components
  (make-storage)
  (let ((entity1 (make-entity))
        (entity2 (make-entity))
        (x1 42.0)
        (y1 42.9)
        (name1 :test)
        (x2 0.0)
        (y2 0.1)
        (name2 :test2))
    (make-coordinate entity1 :x x1 :y y1 :name name1)
    (make-coordinate entity2 :x x2 :y y2 :name name2)
    (is equal (list entity1) (composite :x x1 :name name1))
    (is equal (list entity2) (composite :x x2 :name name2))))

(define-test "component ctors update composite index with identical data"
  :parent components
  (make-storage)
  (let ((entity1 (make-entity))
        (entity2 (make-entity))
        (x 42.0)
        (y 42.9)
        (name :test))
    (make-coordinate entity1 :x x :y y :name name)
    (make-coordinate entity2 :x x :y y :name name)
    (is alexandria:set-equal (list entity1 entity2)
        (composite :x x :name name))))

(define-test "component dtor updates composite index"
  :parent components
  (make-storage)
  (let ((entity (make-entity))
        (x 42.0)
        (y 42.9)
        (name :test))
    (make-coordinate entity :x x :y y :name name)
    (delete-coordinate entity)
    (is equal nil (composite :x x :name name))))

(define-test component-dtors-update-composite-index
  :parent components
  (make-storage)
  (let ((entity1 (make-entity))
        (entity2 (make-entity))
        (x 42.0)
        (y 42.9)
        (name :test))
    (make-coordinate entity1 :x x :y y :name name)
    (make-coordinate entity2 :x x :y y :name name)
    (delete-coordinate entity1)

    (is equal (list entity2)
        (composite :x x :name name))

    (delete-coordinate entity2)
    (is equal nil
        (composite :x x :name name))))

(define-test "component accessor updates composite index"
  :parent components
  (make-storage)
  (let* ((x 42.0)
         (name :test)
         (new-name :test2)
         (entity (make-object `((:coordinate :x ,x :name ,name)))))
    (setf (coordinate-name entity) new-name)
    (is equal nil (composite :x x :name name))
    (is equal (list entity) (composite :x x :name new-name))))

(define-test "with- macro updates composite index"
  :parent components
  (make-storage)
  (let* ((x 42.0)
         (name :test)
         (new-name :test2)
         (entity (make-object `((:coordinate :x ,x :name ,name)))))
    (with-coordinate () entity
      (setf name new-name))
    (is equal nil (composite :x x :name name))
    (is equal (list entity) (composite :x x :name new-name))))

(define-test composite-index-count
  :parent components
  (make-storage)
  (dotimes (_ 3)
    (make-object `((:coordinate :name :a))))
  (is equal '(0 1) (composite :x 0.0 :name :a :count 2)))

(define-test composite-index-start
  :parent components
  (make-storage)
  (dotimes (_ 3)
    (make-object `((:coordinate :name :a))))
  (is equal '(1 2) (composite :x 0.0 :name :a :start 1)))

(define-test duplicate-component
  :parent components
  :depends-on (component-registry new-component-definition)
  (make-storage)
  (let ((entity (make-entity)))
    (make-coordinate entity)
    (run-systems)
    (make-coordinate entity)

    (is equal '(0) (name-entities :||))
    (is equal '(0) (composite :x 0.0 :name :||))
    (is = 0 (sbit (ecs::storage-component-created-bits ecs:*storage*)
                  ecs::+coordinate-component-index+))
    (let ((soa (svref (ecs::storage-component-storages ecs:*storage*)
                      ecs::+coordinate-component-index+)))
      (is = 1 (ecs::component-soa-count soa)))
    #-ecs-release
    (fail (make-object `((:velocity :x 0.1) (:velocity))) warning)))

#+(and (not ecs-release) (or sbcl ccl))
(define-test readonly-compile-time-warning
  :parent components
  (with-fixtures '(ecs::*system-registry*)
    (let ((compilation-output
            (let ((*error-output* (make-string-output-stream)))
              (with-compilation-unit (:override t)
                (compile-file #P"tests/test-component-system-ro.lisp"
                              :verbose nil))
              (get-output-stream-string *error-output*))))
      (true (search "Undefined function" compilation-output))))

  (let ((compilation-output
          (let ((*error-output* (make-string-output-stream)))
            (with-compilation-unit (:override t)
              (compile-file #P"tests/test-component-ro.lisp" :verbose nil))
            (get-output-stream-string *error-output*))))
    (true (search "Undefined function" compilation-output))))

#-ecs-release
(define-test component-redefinition-keeps-data
  :parent components
  :depends-on (component-registry new-component-definition)
  (make-storage)
  (let* ((x 42.0)
         (y 42.9)
         (entity (make-object `((:velocity :x ,x :y ,y)))))
    (eval
     '(define-component (velocity
                         :composite-index (velocity (x y) :unique t))
       (x 0.0 :type single-float)
       (y 0.0 :type single-float)))
    (true (has-velocity-p entity))
    (is = x (velocity-x entity))
    (is = y (velocity-y entity))))

#-ecs-release
(define-test component-redefinition-twice
  :parent components
  :depends-on (component-registry
               new-component-definition
               component-redefinition-keeps-data)
  (make-storage)
  (let* ((x 42.0)
         (y 42.9)
         (entity (make-object `((:velocity :x ,x :y ,y)))))
    (eval
     '(define-component velocity
       (x 0.0 :type single-float)
       (y 0.0 :type single-float)))
    (eval
     '(define-component (velocity
                         :composite-index (velocity (x y) :unique t))
       (x 0.0 :type single-float)
       (y 0.0 :type single-float)
       (z 0.0 :type single-float)))
    (true (has-velocity-p entity))
    (is = x (velocity-x entity))
    (is = y (velocity-y entity))))

(define-test component-count
  :parent components
  (make-storage)
  (is = 0 (coordinate-count))
  (let ((entity1 (make-object `((:coordinate)))))
    (is = 1 (coordinate-count))
    (make-entity)
    (is = 1 (coordinate-count))
    (let ((entity2 (make-object `((:coordinate)))))
      (is = 2 (coordinate-count))
      (delete-entity entity2)
      (is = 1 (coordinate-count)))
    (delete-coordinate entity1)
    (is = 0 (coordinate-count))))

(define-test boxing-warnings
  :parent components
  :depends-on (component-registry new-component-definition)
  (with-fixtures '(ecs::*component-registry* ecs::*component-registry-length*)
    (fail
        (eval
         '(defcomponent velocity2
           (x (make-array 1) :type simple-array)
           (y 0 :type (unsigned-byte 16))))
        style-warning)
    (fail
        (eval
         '(defcomponent velocity3
           (x nil :type list)
           (y 0 :type (unsigned-byte 16))))
        style-warning)
    (fail
        (eval
         '(defcomponent velocity4
           (x (make-hash-table)  :type hash-table)
           (y 0 :type (unsigned-byte 16))))
        style-warning)
    (fail
        (eval
         '(defcomponent velocity5
           (x 0 :type integer)
           (y 0 :type (unsigned-byte 16))))
        style-warning)
    (finish
     (handler-case
         (eval
          '(defcomponent velocity6
            (x "" :type simple-string)
            (y 0 :type (unsigned-byte 16))))
       (style-warning (w)
         (when (search "boxed" (format nil "~a" w))
           (error "there should be no boxing warning here")))))
    (finish
     (handler-case
         (eval
          '(defcomponent velocity7
            (x :test :type keyword)
            (y 0 :type (unsigned-byte 16))))
       (style-warning (w)
         (when (search "boxed" (format nil "~a" w))
           (error "there should be no boxing warning here")))))
    (finish
     (handler-case
         (eval
          '(defcomponent velocity8
            (x #'identity :type function)
            (y 0 :type (unsigned-byte 16))))
       (style-warning (w)
         (when (search "boxed" (format nil "~a" w))
           (error "there should be no boxing warning here"))))))
  #+clisp (setf ecs::*component-registry*
                ;; ¯\_(ツ)_/¯
                (cddr (cddddr ecs::*component-registry*))))

(define-test defcomponent+defsystem-in-different-packages
  :parent components
  :depends-on (component-registry new-component-definition)
  (with-fixtures '(ecs::*system-registry*
                   ecs::*component-registry* ecs::*component-registry-length*)
    (let ((compilation-output
           (let ((*error-output* (make-string-output-stream))
                 (*standard-output* (make-string-output-stream)))
             (finish
              (compile-file #P"tests/test-components-system-packages.lisp"
                            :verbose nil))
             (get-output-stream-string #+ecl *standard-output*
                                       #-ecl *error-output*))))
      (false (search "undefined" compilation-output))))
  #+clisp (setf ecs::*component-registry* (cddr ecs::*component-registry*)))

(define-test component-name-clash-with-cl
  :parent components
  :depends-on (component-registry new-component-definition
                                  #+sbcl defcomponent-with-shadowed-symbol)
  (with-fixtures '(ecs::*system-registry*
                   #+sbcl ecs::*component-registry*
                   #+sbcl ecs::*component-registry-length*)
    (finish
     (eval
      '(defcomponent position
        (x 0.0 :type single-float)
        (y 0.0 :type single-float))))
    (finish
     (eval
      '(defsystem move
        (:components-rw (position))
        (incf position-x)
        (incf position-y))))))

#-ecs-release
(define-test index-redefinition
  :parent components
  :depends-on (component-registry)
  (make-storage)
  (with-fixtures '(ecs::*system-registry*)
    (eval
     '(define-component (velocity
                         :composite-index (velocity (x y) :unique t))
       (x 0.0 :type single-float)
       (y 0.0 :type single-float)
       (gear 0 :type fixnum :index gears)))
    (eval
     '(defsystem move
       (:components-rw (velocity))
       (setf velocity-gear 1)))
    (let ((entity (make-object `((:velocity)))))
      (declare (ignore entity))
      (eval
       '(define-component (velocity
                           :composite-index (velocity (x y) :unique t))
         (x 0.0 :type single-float)
         (y 0.0 :type single-float)
         (gear 0 :type fixnum :index gears)))
      (finish (run-systems)))))

#-ecs-release
(define-test index-redefinition-rebuilds-index
  :parent components
  :depends-on (component-registry)
  (make-storage)
  (eval
   '(progn
     ;; NOTE: safety=3 set in test.lisp makes SBCL throw type error
     (declaim (optimize (safety 2)))
     (define-component velocity
      (x 0.0 :type single-float)
      (y 0.0 :type single-float)
      (gear 0 :type fixnum :index gears))))
  (let ((entity (make-object `((:velocity :gear 1)))))
    (eval
     '(progn
       (declaim (optimize (safety 2)))
       (define-component velocity
        (x 0.0 :type single-float)
        (y 0.0 :type single-float)
        (gear 0.0 :type single-float :index gears))))
    (is equal (list entity) (gears 0.0))))

#-ecs-release
(define-test index-type-redefinition
  :parent components
  :depends-on (component-registry)
  (make-storage)
  (eval
   '(define-component (velocity
                       :composite-index (velocity (x y) :unique t))
     (x 0.0 :type single-float)
     (y 0.0 :type single-float)
     (gear 0.0 :type single-float :index gears)))
  (let ((entity (make-object `((:velocity)))))
    (eval
     '(progn
       ;; NOTE: safety=3 set in test.lisp makes SBCL throw type error
       (declaim (optimize (safety 2)))
       (define-component (velocity
                          :composite-index (velocity (x y) :unique t))
        (x 0.0 :type single-float)
        (y 0.0 :type single-float)
        (gear 0 :type fixnum :index gears))))
    (is equal (list entity) (gears 0))))

#-ecs-release
(define-test composite-index-redefinition
  :parent components
  :depends-on (component-registry)
  (make-storage)
  (eval
   '(define-component (velocity
                       :composite-index (velocity (x y) :unique t))
     (x 0.0 :type single-float)
     (y 0.0 :type single-float)))
  (make-object `((:velocity)))
  (eval
   '(define-component (velocity
                       :composite-index (velocity (x y)))
     (x 0.0 :type single-float)
     (y 0.0 :type single-float)))
  (is equal '(0) (velocity :x 0.0 :y 0.0)))

#-ecs-release
(define-test composite-index-redefinition-rebuilds-index
  :parent components
  :depends-on (component-registry)
  (make-storage)
  (eval
   '(progn
     ;; NOTE: safety=3 set in test.lisp makes SBCL throw type error
     (declaim (optimize (safety 2)))
     (define-component (velocity
                        :composite-index (velocity (x y) :unique t))
      (x 0 :type fixnum)
      (y 0 :type fixnum))))
  (let ((entity (make-object `((:velocity :x 1 :y 1)))))
    (eval
     '(progn
       (declaim (optimize (safety 2)))
       (define-component (velocity
                          :composite-index (velocity (x y) :unique t))
        (x 0.0 :type single-float)
        (y 0.0 :type single-float))))
    (is = entity (velocity :x 0.0 :y 0.0))))

#-ecs-release
(define-test access-new-slot
  :parent components
  :depends-on (component-registry)
  (make-storage)
  (eval
   '(define-component velocity
     (x 0.0 :type single-float)
     (y 0.0 :type single-float)))
  (let ((entity (make-object `((:velocity)))))
    (eval
     '(define-component velocity
       (x 0.0 :type single-float)
       (y 0.0 :type single-float)
       (z 0.0 :type single-float)))
    (is = 0.0 (velocity-z entity))))

#-ecs-release
(define-test component-slot-type-redefinition
  :parent components
  :depends-on (component-registry new-component-definition)
  (make-storage)
  (with-fixtures '(ecs::*component-registry* ecs::*component-registry-length*)
    (let ((entity (make-object `((:velocity :x 1.0 :y 2.0)))))
      (eval
       '(progn
         ;; NOTE: safety=3 set in test.lisp makes SBCL throw type error
         (declaim (optimize (safety 2)))
         (define-component velocity
          (x 0 :type fixnum)
          (y 0 :type fixnum))))
      (is = 0 (velocity-x entity))
      (is = 0 (velocity-y entity)))))

(define-test missing-error-p-only-in-unique
  :parent components
  :depends-on (component-registry new-component-definition)
  (eval
   '(define-component (velocity
                       :composite-index (velocity (x y)))
     (x 0.0 :type single-float)
     (y 0.0 :type single-float)))
  (fail
   (velocity :x 0.0 :y 0.0 :missing-error-p nil)))

(define-test reset-component
  :parent components
  (make-storage)
  (let ((entity (make-object `((:coordinate :x 42.0 :y -1.0)))))
    (reset-coordinate entity)
    (is = 0.0 (coordinate-x entity))
    (is = 0.0 (coordinate-y entity))))

(define-test reset-component-method
  :parent components
  (make-storage)
  (let ((entity (make-object `((:coordinate :x 42.0 :y -1.0)))))
    (reset-component ecs::+coordinate-component-index+ entity)
    (is = 0.0 (coordinate-x entity))
    (is = 0.0 (coordinate-y entity))))

(define-test docstrings
  :parent components
  ;; XXX CLISP randomly skips docstrings, I have no idea why
  #-clisp
  (true (search "COORDINATE" (documentation 'make-coordinate 'function)))
  (true (search "COORDINATE" (documentation 'has-coordinate-p 'function)))
  (true (search "COORDINATE" (documentation 'delete-coordinate 'function)))
  (true (search "COORDINATE" (documentation 'with-coordinate 'function)))
  #-clisp
  (true (search "COORDINATE" (documentation 'assign-coordinate 'function)))
  #-clisp
  (true (search "COORDINATE" (documentation 'reset-coordinate 'function)))
  (true (search "COORDINATE" (documentation 'coordinate-count 'function))))

(define-test generated
  :parent components
  :depends-on (component-registry new-component-definition)
  (eval
   '(defcomponent velocity
     (x 0.0 :type single-float)
     (y 0.0 :type single-float)
     (sum (+ x y) :type single-float :generated-from (x y))))
  (make-storage)
  (let ((entity (make-object `((:velocity)))))
    (setf (velocity-x entity) 1.0
          (velocity-y entity) 2.0)
    (is = 3.0 (velocity-sum entity))))

(define-test generated-forbidden-assignment
  :parent components
  :depends-on (component-registry new-component-definition)
  (eval
   '(defcomponent velocity
     (x 0.0 :type single-float)
     (y 0.0 :type single-float)
     (prod (* x y) :type single-float :generated-from (x y))))
  (make-storage)
  (let ((entity (make-entity)))
    (declare (special entity))
    (fail (make-velocity entity :prod 1.0))
    (fail (make-component ecs::+velocity-component-index+ entity :prod 1.0))
    (make-velocity entity)
    (fail (setf (velocity-prod entity) 1.0))
    (fail
     (with-velocity () entity
        (setf prod 1)))))

(define-test generated-index
  :parent components
  :depends-on (component-registry new-component-definition)
  (eval
   '(defcomponent velocity
     (x 0.0 :type single-float)
     (y 0.0 :type single-float)
     (prod (* x y) :type single-float :generated-from (x y) :index prod-index)))
  (make-storage)
  (let ((entity (make-object `((:velocity)))))
    (declare (special entity))
    (is equal (list entity) (prod-index 0.0))
    (eval
     '(with-velocity () entity
       (setf x 2.0 y 3.0)))
    (is equal (list entity) (prod-index 6.0))))

(define-test generated-composite-index
  :parent components
  :depends-on (component-registry new-component-definition)
  (eval
   '(defcomponent (velocity :composite-index (composite* (x* y*)))
     (x 0.0 :type single-float)
     (y 0.0 :type single-float)
     (x* (1+ x) :type single-float :generated-from (x))
     (y* (1+ y) :type single-float :generated-from (y))))
  (make-storage)
  (let ((entity (make-object `((:velocity)))))
    (is equal (list entity) (composite* :x* 1.0 :y* 1.0))
    (setf (velocity-x entity) 1.0)
    (is equal (list entity) (composite* :x* 2.0 :y* 1.0))))

(define-test generated-composite-index-with-macro
  :parent components
  :depends-on (component-registry new-component-definition)
  (eval
   '(defcomponent (velocity :composite-index (composite* (x* y*)))
     (x 0.0 :type single-float)
     (y 0.0 :type single-float)
     (x* (1+ x) :type single-float :generated-from (x))
     (y* (1+ y) :type single-float :generated-from (y))))
  (make-storage)
  (let ((entity (make-object `((:velocity :x 2.0 :y 2.0))))
        (entity2 (make-object `((:velocity))))
        (entity3 (make-object `((:velocity)))))
    (eval
     `(with-velocity () ,entity
        (setf x 1.0 y (1- most-positive-single-float))
        (setf x 0.0 y 0.0)))
    (is equal (list entity entity2 entity3) (composite* :x* 1.0 :y* 1.0))))

(define-test defcomponent-slot-named-entity
  :parent components
  :depends-on (component-registry new-component-definition)
  (with-fixtures '(ecs::*component-registry* ecs::*component-registry-length*)
    (finish
     (eval
      '(progn
        (defpackage :test-component-entity-slot
          (:use :cl :cl-fast-ecs))
        (in-package :test-component-entity-slot)
        (defcomponent parent
         (entity -1 :type entity))))))
  #+clisp (setf ecs::*component-registry* (cddr ecs::*component-registry*)))
